(defun map-beust-sequence (f max &optional (base 10))
  (let* ((digits (cons nil (loop for i below base collecting i)))
         (before-1 (cdr digits)))
    (labels ((count-it (power-of-base high-order-part &optional (before digits))
      (do ((digit (cdr before) (cdr digit)) number)
          ((not digit))
        (setq number (+ high-order-part (first digit)))
        (if (= power-of-base 1)
          (if (> number max)
            (return-from map-beust-sequence)
            (funcall f number))
          (progn
            (setf (cdr before) (cdr digit))
            (count-it (1- power-of-base) (* number base))
            (setf (cdr before) digit)
            (setq before digit))))))
      (do ((power-of-base 1 (1+ power-of-base)))
          ((> power-of-base base))
        (count-it power-of-base 0 before-1)))))
